home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Especial Multimedia
/
Especial Multimedia.iso
/
Multimed
/
Prg
/
IMAGELIB.ZIP
/
MIMAGE.ZIP
/
UIMAGE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-07-28
|
14KB
|
457 lines
{Part of Imagelib VCL/DLL Library.
Written by Jan Dekkers and Kevin Adams}
{this unit uses the tmultiimage component which must be added, select
Options/Install Components/Add and add reg_im20.pas}
unit Uimage;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, FileCtrl, Reg_im20, VBXCtrl, Switch, Spin,
Buttons, UFullscr, Menus, Uabout, ExtCtrls, Gauges, printers, U_p_size;
type
TForm1 = class(TForm)
DriveComboBox1: TDriveComboBox;
DirectoryListBox1: TDirectoryListBox;
FileListBox1: TFileListBox;
Sstretch: TBiSwitch;
Label1: TLabel;
SaveAs: TBiSwitch;
Label4: TLabel;
SaveDialog1: TSaveDialog;
SaveButton: TBitBtn;
QualitySpin: TSpinEdit;
Smoothspin: TSpinEdit;
QualityLabel: TLabel;
SmoothLabel: TLabel;
GroupBox1: TGroupBox;
res4: TRadioButton;
res24: TRadioButton;
res8: TRadioButton;
GroupBox2: TGroupBox;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
DitherOneNo: TRadioButton;
DitherOneYes: TRadioButton;
DitherTwoNo: TRadioButton;
DitherTwoYes: TRadioButton;
Dither24Bit: TRadioButton;
MainMenu1: TMainMenu;
N1: TMenuItem;
O1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
E1: TMenuItem;
A1: TMenuItem;
OpenDialog1: TOpenDialog;
N4: TMenuItem;
Print1: TMenuItem;
PrintSetup1: TMenuItem;
PrinterSetupDialog1: TPrinterSetupDialog;
PrintDialog1: TPrintDialog;
PrintOptions1: TMenuItem;
MultiImage1: TMultiImage;
Gauge1: TGauge;
Label9: TLabel;
Label10: TLabel;
Label11: TLabel;
Label12: TLabel;
Label13: TLabel;
Label14: TLabel;
Label15: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Edit5: TEdit;
Edit6: TEdit;
Edit7: TEdit;
GetInfoChecked: TCheckBox;
Label8: TLabel;
Edit8: TEdit;
CheckBox1: TCheckBox;
procedure DriveComboBox1Change(Sender: TObject);
procedure DirectoryListBox1Change(Sender: TObject);
procedure FileListBox1Change(Sender: TObject);
procedure SstretchOnOff(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure resClick(Sender: TObject);
procedure DitherClick(Sender: TObject);
procedure SaveButtonClick(Sender: TObject);
procedure MultiImage1Click(Sender: TObject);
procedure E1Click(Sender: TObject);
procedure O1Click(Sender: TObject);
procedure A1Click(Sender: TObject);
procedure setsavevisible(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Print1Click(Sender: TObject);
procedure PrintSetup1Click(Sender: TObject);
procedure PrintOptions1Click(Sender: TObject);
procedure GetInfoCheckedClick(Sender: TObject);
procedure CheckBox1Click(Sender: TObject);
private
{ Private declarations }
oldsavefiles : TstringList;
oldreadfiles : TstringList;
procedure PrintBitmap(Bitmap: TBitmap; X, Y: Integer);
procedure DisPlayInfo(dis : boolean);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
{---------------------------------------------------------------------}
procedure ImageLibCallBack(i : integer); export;
{Callback function from the dll, EXPORT IS REQUIRED}
begin
Form1.Gauge1.Progress:=i;
Application.ProcessMessages;
end;
{---------------------------------------------------------------------}
procedure TForm1.DriveComboBox1Change(Sender: TObject);
{update the drive of DirectoryListBox1 with the drive of DriveComboBox1}
begin
DirectoryListBox1.Drive := DriveComboBox1.Drive;
end;
{---------------------------------------------------------------------}
procedure TForm1.DisPlayInfo(dis : boolean);
begin
if dis then begin
{display the image info}
Edit1.Text:=IntToStr(MultiImage1.Bwidth);
Edit2.Text:=IntToStr(MultiImage1.BHeight);
Edit3.Text:=IntToStr(MultiImage1.Bbitspixel);
Edit4.Text:=IntToStr(MultiImage1.Bplanes);
Edit5.Text:=IntToStr(MultiImage1.Bnumcolors);
Edit6.Text:=MultiImage1.BFileType;
Edit7.Text:=MultiImage1.Bcompression;
Edit8.Text:=IntToStr(MultiImage1.BSize);
end else begin
{set the image info to ''}
Edit1.Text:='';
Edit2.Text:='';
Edit3.Text:='';
Edit4.Text:='';
Edit5.Text:='';
Edit6.Text:='';
Edit7.Text:='';
Edit8.Text:='';
end;
end;
{---------------------------------------------------------------------}
procedure TForm1.DirectoryListBox1Change(Sender: TObject);
{update the directory of FileListBox1 with the directory of FileListBox1}
begin
FileListBox1.Directory := DirectoryListBox1.Directory;
end;
{---------------------------------------------------------------------}
procedure TForm1.FileListBox1Change(Sender: TObject);
{Display the image of the FileListBox1.filename}
begin
{set hourglass cursor}
screen.cursor:=crHourGlass;
{delete the old image}
MultiImage1.imagename:='';
{display an image using the vcl}
MultiImage1.imagename:=FileListBox1.filename;
{Request fileinfo from the DLL}
{Note, fileinfo will not work on WMF and ICO}
if GetInfoChecked.Checked then
DisplayInfo(true) else DisplayInfo(false);
{Reset the gauge}
Gauge1.Progress:=0;
{add filename to the history list of the open dialog}
oldreadfiles.add(FileListBox1.filename);
{copy the stringlist to the historylist}
OpenDialog1.historylist:=oldreadfiles;
{set default cursor}
screen.cursor:=crDefault;
end;
{---------------------------------------------------------------------}
procedure TForm1.SstretchOnOff(Sender: TObject);
{set strech mode}
begin
MultiImage1.stretch:=Sstretch.Pon;
end;
{---------------------------------------------------------------------}
procedure TForm1.setsavevisible(Sender: TObject);
{hide or show jpeg save options}
begin
QualitySpin.visible:=SaveAs.Pon;
Smoothspin.visible:=SaveAs.Pon;
QualityLabel.visible:=SaveAs.Pon;
SmoothLabel.visible:=SaveAs.Pon;
end;
{---------------------------------------------------------------------}
procedure TForm1.FormCreate(Sender: TObject);
{what we do on create}
begin
{Define the callback procedure}
TMultiImageCallBack:=ImageLibCallBack;
{set the value of the QualitySpin to the value of JPegSaveQuality}
QualitySpin.value:=MultiImage1.JPegSaveQuality;
{set the value of the Smoothspin to the value of JPegSaveSmooth}
Smoothspin.value:=MultiImage1.JPegSaveSmooth;
{show the save options depending on the saveas switch pon state}
setsavevisible(sender);
{create temporary history stringlists}
oldsavefiles := TstringList.create;
oldreadfiles := TstringList.create;
end;
{---------------------------------------------------------------------}
procedure TForm1.resClick(Sender: TObject);
{Set the jpeg resolution to either 16, 256 or true color in the vcl}
begin
{set jpeg show resolution to 4 bit 16 color}
if res4.checked then MultiImage1.JPegResolution:=4;
{set jpeg show resolution to 8 bit 256 color}
if res8.checked then MultiImage1.JPegResolution:=8;
{set jpeg show resolution to 24 bit true color}
if res24.checked then MultiImage1.JPegResolution:=24;
end;
{---------------------------------------------------------------------}
procedure TForm1.DitherClick(Sender: TObject);
{Set the jpeg dither in the vcl}
begin
{set the jpeg show dither to none (best choice for true color 24 bit}
if Dither24Bit.checked then MultiImage1.JPegDither:=0;
{set the jpeg show dither to one pass none}
if DitherOneNo.checked then MultiImage1.JPegDither:=1;
{set the jpeg show dither to one pass dithered (best choice for 16 colors)}
if DitherOneYes.checked then MultiImage1.JPegDither:=2;
{set the jpeg show dither to one pass none}
if DitherTwoNo.checked then MultiImage1.JPegDither:=3;
{set the jpeg show dither to two pass dithered (best choice for 256 colors)}
if DitherTwoYes.checked then MultiImage1.JPegDither:=4;
end;
{---------------------------------------------------------------------}
procedure TForm1.SaveButtonClick(Sender: TObject);
{save a jpeg or bmp}
begin
{open save dialog}
if SaveDialog1.execute then begin
{set hourglass cursor}
screen.cursor:=crHourGlass;
{save it if the extension is jpg}
if UpperCase(ExtractFileExt(SaveDialog1.Filename)) = '.JPG' then
MultiImage1.SaveAsJpg(SaveDialog1.FileName);
{save it if the extension is bmp}
if UpperCase(ExtractFileExt(SaveDialog1.Filename)) = '.BMP' then
MultiImage1.Picture.SaveToFile(SaveDialog1.FileName);
{add filename to the history list of the save dialog}
oldSavefiles.add(SaveDialog1.filename);
{copy the stringlist to the historylist}
SaveDialog1.historylist:=oldSavefiles;
{set default cursor}
screen.cursor:=crDefault;
{update the filelist box sothat the file saved shows up}
FileListBox1.Update;
end;
end;
{---------------------------------------------------------------------}
procedure TForm1.MultiImage1Click(Sender: TObject);
{show fullscreen}
begin
{copy image to fullscreen image}
FullSlide.MultiImage1.Picture.Graphic:=MultiImage1.Picture.Graphic;
{show the image fulscreen}
FullSlide.showmodal;
end;
{---------------------------------------------------------------------}
procedure TForm1.E1Click(Sender: TObject);
{exit the program}
begin
close;
end;
{---------------------------------------------------------------------}
procedure TForm1.O1Click(Sender: TObject);
{open a image using the open dialog}
begin
if OpenDialog1.execute then begin
{set hourglass cursor}
screen.cursor:=crHourGlass;
{delete the old image}
MultiImage1.imagename:='';
{display an image using the vcl}
MultiImage1.imagename:=OpenDialog1.filename;
{Request fileinfo from the DLL}
{Note, fileinfo will not work on WMF and ICO}
if GetInfoChecked.Checked then
DisplayInfo(true) else DisplayInfo(false);
{reset the gauge}
Gauge1.Progress:=0;
{add filename to the history list of the open dialog}
oldreadfiles.add(OpenDialog1.filename);
{copy the stringlist to the historylist}
OpenDialog1.historylist:=oldreadfiles;
{set default cursor}
screen.cursor:=crDefault;
end;
end;
{---------------------------------------------------------------------}
procedure TForm1.A1Click(Sender: TObject);
{about box}
begin
{Copy the image to the image of he about box}
AboutBox.Image1.Picture.Graphic:=MultiImage1.Picture.Graphic;
{show the about box}
AboutBox.showmodal;
end;
{---------------------------------------------------------------------}
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
{what to do on exit}
begin
{release memory of the stringlist boxes}
oldsavefiles.free;
oldreadfiles.free;
end;
{---------------------------------------------------------------------}
procedure TForm1.Print1Click(Sender: TObject);
{Print image}
begin
if PrintDialog1.execute then begin
{Sent the doc to the printer}
Printer.Begindoc;
{Print the TDBMultiImage bitmap}
PrintBitmap(MultiImage1.Picture.Bitmap,0,0);
{End the printjob and close the bitmap}
Printer.Enddoc;
end;
end;
{---------------------------------------------------------------------}
procedure TForm1.PrintSetup1Click(Sender: TObject);
{Set up printer}
begin
PrinterSetupDialog1.Execute;
end;
{---------------------------------------------------------------------}
procedure TForm1.PrintBitmap(Bitmap: TBitmap; X, Y: Integer);
{Print using borland's how to print a bitmap example code}
var
Info: PBitmapInfo;
InfoSize: Integer;
Image: Pointer;
ImageSize: Longint;
begin
with Bitmap do
begin
GetDIBSizes(Handle, InfoSize, ImageSize);
Info := MemAlloc(InfoSize);
try
Image := MemAlloc(ImageSize);
try
GetDIB(Handle, Palette, Info^, Image^);
with Info^.bmiHeader do begin
if (Printersize.HeigthSpinEdit.Value >1) and (Printersize.WidthSpinEdit.Value >1) then
StretchDIBits(Printer.Canvas.Handle, X, Y, Printersize.WidthSpinEdit.Value,
Printersize.HeigthSpinEdit.Value, 0, 0, biWidth, biHeight, Image, Info^,
DIB_RGB_COLORS, SRCCOPY)
else
StretchDIBits(Printer.Canvas.Handle, X, Y, Width,
Height, 0, 0, biWidth, biHeight, Image, Info^,
DIB_RGB_COLORS, SRCCOPY);
end;
finally
FreeMem(Image, ImageSize);
end;
finally
FreeMem(Info, InfoSize);
end;
end;
end;
{---------------------------------------------------------------------}
procedure TForm1.PrintOptions1Click(Sender: TObject);
{select the size}
begin
{Initialize the height spinedit of the printsize dialog box}
Printersize.HeigthSpinEdit.Value:=MultiImage1.Picture.BitMap.Height;
{Initialize the width spinedit of the printsize dialog box}
Printersize.WidthSpinEdit.Value:=MultiImage1.Picture.BitMap.Width;
{Show it}
Printersize.ShowModal;
{Hide it if done}
Printersize.hide;
end;
{---------------------------------------------------------------------}
procedure TForm1.GetInfoCheckedClick(Sender: TObject);
{depending on the state of the checkbox, display or not display info}
begin
DisPlayInfo(GetInfoChecked.Checked);
end;
{---------------------------------------------------------------------}
procedure TForm1.CheckBox1Click(Sender: TObject);
{depending on the state of the checkbox, center or not center image}
begin
MultiImage1.Center:=CheckBox1.Checked;
end;
{---------------------------------------------------------------------}
{---------------------------------------------------------------------}
{---------------------------------------------------------------------}
end.